{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} -- TypeSynonymInstances

-- |music theory in haskell
--
-- goal: graph where nodes are legal chord voicings, arcs connect legal voice leadings, with cost = sum of the halfstep changes in each voice
--
-- generalized to n halfsteps per octave, where rules like 'no parallels,' 'omittable fifth,' 'prepare\/resolve dissonances,' 'no doubled dissonance,' etc determined by freq ratios (near 3:2, not near third\/sixth, etc)
--
-- * ghc, haddock, and cabal available as <http://www.macports.org/>
--
-- * haskell xcode plugin <http://hoovy.org/HaskellXcodePlugin/> (from 2007, doesn't work in xcode 3)
--
-- * generate html docs using @haddock -ho ..\/doc *.hs@ <http://haskell.org/haddock/>
--
-- * generate html docs with src using @.\/makeDoc@ (requires HsColour <http://hackage.haskell.org/package/hscolour>)
--
--   install hscolour with @cabal install hscolour@ <http://www.haskell.org/cabal/>
--
-- * compile with @ghc -o ..\/theory --make Main -outputdir ..\/build@

{-

WhiteKey
Eq, Show, Bounded, Enum,      Cyc, MetricCyc, Steppable

Accidental
Eq, Show, Bounded, Enum, Ord,                 Steppable

Pitchclass
Eq, Show, Bounded, Enum,      Cyc, MetricCyc, Steppable

Octave
Eq, Show,          Enum, Ord,                 Steppable, Num, Real, Integral

Note
Eq, Show,          Enum, Ord,                 Steppable, Num, Real, Integral

MidiNum
Eq, Show,          Enum, Ord,                 Steppable, Num, Real, Integral

Chord
Eq, Show

-}

module Theory {- (
      Steppable(..)
    , WhiteKey(..)
--  , numWhiteKeys
    , Accidental(..)
--  , numAccidentals
    , PitchClass(..)
    , Note(..)
    , octave
    , chord
--  , midiNumRef
    , midiNum
    , midiNums
    , halfStepSeq
--  , freqRef
    , freq
    , freqs
    , midiNumFromFreq
    ) where
-} where

import Utility (
      list
    , enumDiff
    , mapPairs
    , numElems
    )

import Cyc (
      Cyc
    , MetricCyc
    , metricDist
    , loopMetric
    , metric
    , metricDiff
    , metricTravel
    )

import Data.Function (on)

import Data.Maybe (fromMaybe)

default ()

-- *classes

-- |minimal complete definition:
-- 'halfStepsAbove'
class Steppable a where
    halfStepsAbove :: a
                   -> a
                   -> Int -- ^number halfsteps /up/ from the 1st to the 2nd arg

-- *types

-- *WhiteKey

-- |first element determines octave breaks
data WhiteKey = C | D | E | F | G | A | B
    deriving(Eq, Show, Bounded, Enum) -- specifically NOT Ord (and therefore not Real), because cyclic

instance Cyc WhiteKey

instance MetricCyc Int WhiteKey where
    metric = const [2,2,1,2,2,2,1]

instance Steppable WhiteKey where
    halfStepsAbove = metricDiff

-- *Accidental

data Accidental = DoubleFlat | Flat | Natural | Sharp | DoubleSharp
    deriving(Eq, Bounded, Enum, Ord) -- not Num (and therefore neither Real nor Integral) because (*), abs, etc don't make a lot of sense

instance Steppable Accidental where
    halfStepsAbove = enumDiff

instance Show Accidental where
    show x = case x of
        DoubleFlat  -> "bb"
        Flat        -> "b"
        Natural     -> ""
        Sharp       -> "#"
        DoubleSharp -> "x"

-- *PitchClass

data PitchClass = PitchClass {
      whiteKey   :: WhiteKey
    , accidental :: Accidental
    } deriving(Eq, Bounded) -- specifically NOT Ord (and therefore not Real), because cyclic

instance Show PitchClass where
    show x = show (whiteKey x) ++ show (accidental x)

instance Enum PitchClass where
    toEnum x = PitchClass {whiteKey = toEnum w, accidental = toEnum a}
        where (w,a)                       = divMod x (numElems $ accidental $ pitchClass $ snd midiNumRef)

    fromEnum p@(PitchClass {accidental = a}) = (fromEnum $ whiteKey p) * (numElems a) + fromEnum a

instance Cyc PitchClass

-- |this is meant to formally prove that 'PitchClass'es inherit their 'loopMetric' from 'WhiteKey's
instance MetricCyc Int PitchClass where -- would be nice to not say 'Int' here, and inherit it from WhiteKey...
    metric _ = h ++ [(metricDist 1 $ whiteKey lp) + (halfStepsAbove (accidental lp) $ accidental p)]
        where h        = fromMaybe [] $ mapPairs halfStepsAbove ps
              ps@(p:_) = list::[PitchClass]  -- assumes there is at least 1 PitchClass, should we worry about 0?
              lp       = last ps

instance Steppable PitchClass where
    halfStepsAbove PitchClass {whiteKey = w1, accidental = a1}
                   PitchClass {whiteKey = w2, accidental = a2}
                        = (halfStepsAbove w1 w2) + halfStepsAbove a1 a2

-- *Octave

newtype Octave = Octave Int
    deriving(Eq, Show, Ord, Num, Integral, Real, Enum)

instance Steppable Octave where
    halfStepsAbove = halfStepsAbove `on` (\o -> ((snd midiNumRef) {oct = o}))

-- |'Octave' constructor
octave :: Int
       -> Octave
octave = Octave

-- *Note

data Note = Note {
      pitchClass :: PitchClass
    , oct        :: Octave
    } deriving(Eq, Show)

instance Enum Note where
    toEnum x = Note {pitchClass = toEnum p, oct = fromIntegral o}
        where (o,p) = divMod x ((numElems $ accidental pc) * (numElems $ whiteKey pc))
--            (o,p) = divMod x (((*) `on` numElems) (accidental pc) (whiteKey pc)) -- this is cooler, but `on` isn't generic enough...
              pc    = pitchClass $ snd midiNumRef

    fromEnum n@(Note {pitchClass=p}) = product [fromIntegral $ oct n, numElems $ whiteKey p, numElems $ accidental p] + fromEnum p

-- |ordering is ...B\# Bx Cbb Cb C C\# Cx Dbb Db... (think height on staff, not freq -- oddly, i think this is what is relavent for voice crossing, and anyway is a full rather than partial ordering)
instance Ord Note where
--  compare x y = (compare 0) $ halfStepsAbove x y
    compare = compare `on` fromEnum

instance Steppable Note where
    halfStepsAbove Note {pitchClass = p1, oct = o1}
                   Note {pitchClass = p2, oct = o2}
        = (fromIntegral (o2 - o1)) * ((loopMetric p1)::Int) + halfStepsAbove p1 p2

instance Num Note where -- we are mostly doing this to get fromInteger, even though (*), signum don't make sense
    (+) x  = fromInteger . ((+) `on` toInteger) x
    negate = fromInteger . negate . toInteger -- without this, (-1)::Note loops, i think interpreted as (negate 1)::Note, which would have no definition -- don't understand why it's not required for Num
    (*)    = undefined
    abs    = id
    signum = undefined

    -- |chooses one of the several Notes with MidiNum x
    fromInteger x = Note newp (o + octs)
        where (m, Note {pitchClass = p, oct = o}) = midiNumRef
              Just (octs, newp)                   = metricTravel ugh p -- assume we can travel exactly any integral distance -- maybe make a predicate on MetricCyc to test this...  (just that all enums up to loopMetric available)
              ugh                                 = ((fromIntegral x) - (fromIntegral m))::Int                      -- ugh!
--            ugh                                 = ((-) `on` fromIntegral) x m                                     -- what i really want -- why doesn't this work?
--            ugh                                 = ((fromIntegral x) - (fromIntegral m)) `asTypeOf` (loopMetric p) -- why doesn't this work?

{- need a way to do the following (Data.Function.on with an 'existential class') but #Haskell makes it look like it might not be doable
infixl 0 `onP`
onP :: (K a1, K a2, K a3) => (b -> b -> c) -> (a3 -> b) -> a1 -> a2 -> c
(.*.) `onP` f = \x y -> f x .*. f y
-}

instance Real Note where
    toRational = toRational . toInteger

instance Integral Note where
    toInteger = ((toInteger r) +) . toInteger . halfStepsAbove n
        where (r, n) = midiNumRef
    quotRem = undefined

-- *MidiNum

newtype MidiNum = MidiNum Int
    deriving(Eq, Show, Ord, Num, Enum, Real, Integral)

instance Steppable MidiNum where
--  halfStepsAbove = ((fromInteger . toInteger) .) . subtract -- ew
    halfStepsAbove x = fromInteger . toInteger . subtract x
--  halfStepsAbove x y = fromInteger $ toInteger (y - x)
--  halfStepsAbove = fromInteger . ((flip -) `on` toInteger)

-- |'MidiNum' constructor
midiNum :: Integral a => a
                      -> MidiNum
midiNum = MidiNum . fromInteger . toInteger

-- *Chord

newtype Chord = Chord [Note]
    deriving(Eq, Show) -- Enum would require an infinitely dimensional diagnolization, it's equivalent to enumerating all tuples of integers.  however, we will probably soon be able to do this by restricting to 4 voices and finite note domain...  we'd probably implement Ord, but not Num, and therefore not Real or Integral...

-- |'Chord' constructor
chord :: [Note]
      -> Chord
chord = Chord

-- *functions

midiNumRef :: (MidiNum, Note)
midiNumRef = (MidiNum 60, Note (PitchClass C Natural) (Octave 4))

-- |self explanatory
midiNums :: Chord
         -> [MidiNum]
midiNums (Chord ns) = map midiNum ns

-- |intervalic pattern
--  ex: @halfStepSeq [Note(PitchClass C Natural) 3,Note(PitchClass E Flat) 3,Note(PitchClass G Flat) 3,Note(PitchClass B Flat) 3] = [3,3,4]@ (a halfdiminished 7)
halfStepSeq :: Chord         -- ^length >= 2
            -> Maybe [Int]   -- ^'Nothing' iff applied to 'Chord' with less than 2 'Note's, otherwise, for a 'Chord' with n 'Note's, 'Just' a list of n-1 numbers of halfsteps that separate the 'Note's, in the order they appeared
halfStepSeq (Chord ns) = mapPairs halfStepsAbove ns

-- |frequncy for a 'Note' in Hz, assumes nTET
freq :: Note
     -> Double
freq n = r * 2 ** ((fromIntegral $ halfStepsAbove nR n) / (fromIntegral $ ((loopMetric $ pitchClass n)::Int))) -- assumes nonzero loopMetric -- if octaves were cyclical, why does this make freq blow up?
    where (r, nR) = freqRef

freqRef :: (Double, Note)
freqRef = (440, Note (PitchClass A Natural) (Octave 4))

-- |self explanatory
freqs :: Chord
      -> [Double]
freqs (Chord ns) = map freq ns

-- |self explanatory
--  we don't use the Integral 'MidiNum' type because we want to express fractional notes
midiNumFromFreq :: Double
                -> Double
midiNumFromFreq x = (fromIntegral $ ((loopMetric $ pitchClass n)::Int)) * (logBase 2 (x / r)) + (fromIntegral $ midiNum n) -- assumes nonzero loopMetric -- if octaves were cyclical, why does this give midiNum = 0?
    where (r, n) = freqRef
